﻿#include once "Afx/CVAR.inc"
'CLSCTX_INPROC_SERVER = &H1
'CLSCTX_INPROC_HANDLER = &H2
'CLSCTX_LOCAL_SERVER = &H4
'CLSCTX_REMOTE_SERVER = &H10

Enum vbtype
   vbEmpty = 0
   vbNull = 1
   vbInteger = 2
   vbLong = 3
   vbSingle = 4
   vbDouble = 5
   vbCurrency = 6
   vbDate = 7
   vbString = 8
   vbObject = 9
   vbError = 10
   vbBoolean = 11
   vbVariant = 12
   vbDataObject = 13
   vbDecimal = 14
   vbByte = 17
   vbUserDefinedType = 36
   vbArray = 8192
End Enum

Enum vbcalltype
   vbMethod = 1
   vbGet = 2
   vbLet = 4
   vbSet = 8
End Enum

Type EventParameter
   ParameterName as String
   Value as Variant
End Type

Type Parameters
   Count as Long
   Item(Any) as EventParameter
End Type

Type EventInfo
   EventID as Long
   EventName as String
   EventParameters as Parameters
End Type

Type CIUnknown Extends Object
   Declare Virtual Function QueryInterface(ByVal riid As REFIID, ByVal ppvObject As LPVOID Ptr) As HRESULT'0
   Declare Virtual Function AddRef() As ULong
   Declare Virtual Function Release() As ULong
Public : 
   EventIID AS IID
   dwCookie as DWORD
   'm_obj as IDispatch ptr
Private : 
   cRef As ULong
End Type

Function CIUnknown.QueryInterface(ByVal riid As REFIID, ByVal ppvObject As LPVOID Ptr) As HRESULT
   If ppvObject = Null Then Return E_INVALIDARG
   If IsEqualIID(riid, @EventIID) Or IsEqualIID(riid, @IID_IUnknown) Or IsEqualIID(riid, @IID_IDispatch) Or IsEqualIID(riid, @IID_IClassFactory) Then
       *ppvObject = @this
      Cast(Afx_IUnknown Ptr, *ppvObject)->AddRef
      Return S_OK
   End If
   Return E_NOINTERFACE
End Function

Function CIUnknown.AddRef() As ULong
   This.cRef += 1
   Function = This.cRef
End Function

Function CIUnknown.Release() As ULong
   This.cRef -= 1
   Function = This.cRef
End Function
Type IEvent
   ObectEvent as SUB(byval Info As EventInfo)
End Type

Type CIDispatch Extends CIUnknown
Protected : 
   Declare Virtual Function GetTypeInfoCount(ByVal pctinfo As UINT Ptr) As HRESULT
   Declare Virtual Function GetTypeInfo(ByVal iTInfo As UINT, ByVal lcid As LCID, ByVal ppTInfo As ITypeInfo Ptr Ptr) As HRESULT
   Declare Virtual Function GetIDsOfNames(ByVal riid As Const IID Const Ptr, ByVal rgszNames As LPOLESTR Ptr, ByVal cNames As UINT, ByVal lcid As LCID, ByVal rgDispId As DISPID Ptr) As HRESULT
   Declare Virtual Function Invoke(ByVal dispIdMember As DISPID, ByVal riid As Const IID Const Ptr, ByVal lcid As LCID, ByVal wFlags As WORD, ByVal pDispParams As DISPPARAMS Ptr, ByVal pVarResult As VARIANT Ptr, ByVal pExcepInfo As EXCEPINFO Ptr, ByVal puArgErr As UINT Ptr) As HRESULT
End Type

Function CIDispatch.GetTypeInfoCount(ByVal pctinfo As UINT Ptr) As HRESULT
    *pctInfo = 0
   Return E_NOTIMPL
End Function

Function CIDispatch.GetTypeInfo(ByVal iTInfo As UINT, ByVal lcid As LCID, ByVal ppTInfo As ITypeInfo Ptr Ptr) As HRESULT
   Return E_NOTIMPL
End Function

Function CIDispatch.GetIDsOfNames(ByVal riid As Const IID Const Ptr, ByVal rgszNames As LPOLESTR Ptr, ByVal cNames As UINT, ByVal lcid As LCID, ByVal rgDispId As DISPID Ptr) As HRESULT
   Return E_NOTIMPL
End Function

Function CIDispatch.Invoke(ByVal dispIdMember As DISPID, ByVal riid As Const IID Const Ptr, ByVal lcid As LCID, ByVal wFlags As WORD, ByVal pDispParams As DISPPARAMS Ptr, ByVal pVarResult As VARIANT Ptr, ByVal pExcepInfo As EXCEPINFO Ptr, ByVal puArgErr As UINT Ptr) As HRESULT
   return S_OK
End Function

Type VB
Private : 
   hmod As HMODULE
Public : 
   obj As IDispatch Ptr

Public : 
   Declare FUNCTION GetObject(BYREF ProgID AS CONST WSTRING) AS IDispatch PTR
   '获得活动对象 参数 ：对象类名（如Excel.Application）
   Declare FUNCTION CreateObjectFromLib(BYREF wszLibName AS CONST WSTRING, ByVal sclsid AS LPCOLESTR, BYREF sriid AS CONST WSTRING = "{00020400-0000-0000-C000-000000000046}", BYREF wszLicKey AS WSTRING = "") AS ANY PTR
   '动态调用Activex Dll 参数：DLL文件全名，类ID（注非类名，如{00024413-0001-0000-C000-000000000046}），接口IID，如得到自动化接口可省略
   Declare FUNCTION CreateObject(BYREF ProgID AS CONST WSTRING, BYREF wszIID AS CONST WSTRING = "{00020400-0000-0000-C000-000000000046}") AS ANY PTR
   '创建一个COM组件，参数：类名（如Excel.Application），接口IID，如得到自动化接口可省略
   Declare FUNCTION CallByName(byval pDisp as IDispatch ptr, byval ptName as LPOLESTR, byval autoType as vbcalltype, byval pvResult as VARIANT ptr, byval cArgs as long, ByVal ParamArray as VARIANT ptr) as HRESULT
   'object，函数名，函数类型（DISPATCH_METHOD,DISPATCH_PROPERTYGET,DISPATCH_PROPERTYPUT,DISPATCH_PROPERTYPUTREF），返回值 （Variant ptr无传NULL），参数个数（无传0），参数(全部用VARIANT（）类型，可使用CVAR转，注：参数顺序为从右到左)……
   Declare FUNCTION FreeObject(byval pDisp as IDispatch ptr) as HRESULT
   ''释放COM组件，注意不是退出，仅释放引用，如组件需退出需在此之前调用退出函数，有多少引用，必须调用几次，否则会出现内存泄露
   Declare FUNCTION WithEvents(byval pDisp as IDispatch ptr, byval pEvtObj As CIUnknown ptr) as HRESULT
   '引用事件 参数：被引用事件组件对象如Excelapp,事件对象（需要创建CEvent或CIUnknown对象）
   Declare FUNCTION UnWithEvents(byval pDisp as IDispatch ptr, byval pEvtObj As CIUnknown ptr) AS HRESULT
   '释放事件对象，如引用过事件，此步必须使用，否则会出现内存泄露
  Declare FUNCTION CreateControl(byval sClsid as LPCWSTR, byval X as long, byval Y as long, byval nWidth as long, byval nHeight as long, byval hWndParent as HWND, byval hInstance as HINSTANCE) as IDispatch Ptr
  '创建ocx控件，参数：ocx clsid可由tlb viewer导出，x,y,nwidth,nheight为坐标，hwndparent 父窗口句柄，hInstance程序句柄
  Declare FUNCTION AttachControl(BYVAL pControl AS IUnknown PTR, BYVAL hCtl AS HWND) AS HRESULT
  '
   'Declare CONSTRUCTOR()
   'Declare Destructor()
   'DECLARE OPERATOR Let (BYVAL value AS IDispatch ptr)
   'DECLARE SUB Put (BYVAL pdisp AS IDispatch PTR)
End Type
'OPERATOR VB.Let(BYVAL value AS IDispatch ptr)
'obj=value
'END OPERATOR
'CONSTRUCTOR VB()
'obj=NULL
'End Constructor
'
'Destructor VB()
'if this.obj <> NULL then IUnknown_Release (this.obj)
'End Destructor
FUNCTION VB.AttachControl(BYVAL pControl AS IUnknown PTR, BYVAL hCtl AS HWND) AS HRESULT   if hmod = 0 then
      Dim AtlAxWinInit As function() As long
      hmod = LoadLibrary("Atl.dll")
      'OleInitialize(NULL)
      AtlAxWinInit = GetProcAddress(hmod, "AtlAxWinInit") '
      AtlAxWinInit()
   End if
   DIM pProc AS FUNCTION (BYVAL pControl AS IUnknown PTR, BYVAL hCtl AS HWND, BYVAL ppUnkContainer AS IUnknown PTR PTR) AS HRESULT
   pProc = CAST(ANY PTR, GetProcAddress(hmod, "AtlAxAttachControl"))
   IF pProc = NULL THEN RETURN FALSE
   RETURN pProc(pControl, hCtl, NULL)
END FUNCTION


FUNCTION VB.CreateControl(byval sClsid as LPCWSTR, byval X as long, byval Y as long, byval nWidth as long, byval nHeight as long, byval hWndParent as HWND, byval hInstance as HINSTANCE) as IDispatch Ptr
   Dim o As IDispatch Ptr
   Dim h As HWND, v As VB ptr, ret as VARIANT, p(1) as VARIANT
   if hmod = 0 then
      Dim AtlAxWinInit As function() As long
      hmod = LoadLibrary("Atl.dll")
      'OleInitialize(NULL)
      AtlAxWinInit = GetProcAddress(hmod, "AtlAxWinInit") '
      AtlAxWinInit()
   End if
   Dim AtlAxGetControl As SUB(ByVal h As HWND, ByVal p As IDispatch ptr ptr)
   AtlAxGetControl = CAST(ANY PTR, GetProcAddress(hmod, "AtlAxGetControl"))
   h = CreateWindowEx(0, "AtlAxWin", sClsid, WS_CHILD Or WS_VISIBLE, x, y, nWidth, nHeight, hWndParent, 0, hInstance, 0)
   AtlAxGetControl(h, @o)
   Return o
End Function


FUNCTION VB.WithEvents(byval pDisp as IDispatch ptr, byval pEvtObj As CIUnknown ptr) as HRESULT
   IF pEvtObj = NULL THEN RETURN E_POINTER
   dim m_dwCookie as DWORD = 0
   DIM pCPC AS IConnectionPointContainer PTR
   DIM hr AS HRESULT = IUnknown_QueryInterface(pDisp, @IID_IConnectionPointContainer, @pCPC)
   IF hr <> S_OK OR pCPC = NULL THEN RETURN hr
   DIM pCP AS IConnectionPoint PTR
   Dim riid As IID = pEvtObj->EventIID
   IF hr <> S_OK or @riid = NULL THEN
      msgbox "1:"& str(hr)
      IUnknown_Release(pCPC)
      RETURN hr
   END IF
   hr = pCPC->lpvtbl->FindConnectionPoint(pCPC, @riid, @pCP)
   IF hr <> S_OK OR pCP = NULL THEN
      msgbox "2:"& str(hr)
      IUnknown_Release(pCPC)
      RETURN hr
   END IF
   IF pEvtObj->dwCookie THEN hr = pCP->lpvtbl->Unadvise(pCP, pEvtObj->dwCookie)
   IF hr <> S_OK OR pCP = NULL THEN
      msgbox "3:" + str(hr)
      IUnknown_Release(pCPC)
      RETURN hr
   END IF
   pEvtObj->dwCookie = 0
   hr = pCP->lpvtbl->Advise(pCP, CAST(ANY PTR, pEvtObj), @m_dwCookie)
   IF hr <> S_OK OR pCP = NULL THEN
      msgbox "4：" + str(hr)
      IUnknown_Release(pCPC)
      RETURN hr
   END IF
   pEvtObj->dwCookie = m_dwCookie
   IUnknown_Release(pCPC)
   IUnknown_Release(pCP)
   RETURN hr
End Function

FUNCTION VB.UnWithEvents(byval pDisp as IDispatch ptr, byval pEvtObj As CIUnknown ptr) AS HRESULT
   IF pEvtObj->dwCookie = 0 THEN RETURN E_POINTER
   DIM pCPC AS IConnectionPointContainer PTR
   DIM hr AS HRESULT = pDisp->lpvtbl->QueryInterface(pDisp, @IID_IConnectionPointContainer, @pCPC)
   IF hr <> S_OK OR pCPC = NULL THEN RETURN hr
   DIM pCP AS IConnectionPoint PTR
   Dim m_riidEvt As IID = pEvtObj->EventIID
   hr = pCPC->lpvtbl->FindConnectionPoint(pCPC, @m_riidEvt, @pCP)
   IF hr <> S_OK OR pCP = NULL THEN
      IUnknown_Release(pCPC)
      RETURN hr
   END IF
   hr = pCP->lpvtbl->Unadvise(pCP, pEvtObj->dwCookie)
   pEvtObj->dwCookie = 0
   IUnknown_Release(pCPC)
   IUnknown_Release(pCP)
   RETURN hr
END FUNCTION

Function VB.FreeObject(byval pDisp as IDispatch ptr) as HRESULT
   Return IUnknown_Release(pDisp)
End Function

Function VB.CallByName(byval pDisp as IDispatch ptr, byval ptName as LPOLESTR, byval autoType as vbcalltype, byval pvResult as VARIANT ptr, byval cArgs as long, ByVal ParamArray as VARIANT ptr) as HRESULT
   'object，函数名，函数类型（DISPATCH_METHOD,DISPATCH_PROPERTYGET,DISPATCH_PROPERTYPUT,DISPATCH_PROPERTYPUTREF），返回值 （Variant ptr无传NULL），参数个数（无传0），参数(全部用VARIANT（）类型，可使用CVAR转，注：参数顺序为从右到左)……
   dim dp as DISPPARAMS
   dim dispidNamed as DISPID = DISPID_PROPERTYPUT
   dim dispID as DISPID
   dim IID_NULL as IID
   dim hr as HRESULT = pDisp->lpVtbl->GetIDsOfNames(pDisp, @IID_NULL, @ptName, 1, LOCALE_USER_DEFAULT, @dispID)
   'MsgBox Str( dispID)
      if hr <> 0 Then
      MsgBox "函数未找到:" + Str(hr)
      Exit Function
   End If
   dp.cArgs = cArgs
   dp.rgvarg = ParamArray
   if autoType and DISPATCH_PROPERTYPUT then
      dp.cNamedArgs = 1
      dp.rgdispidNamedArgs = @dispidNamed
   end if
   hr = pDisp->lpVtbl->Invoke(pDisp, dispID, @IID_NULL, LOCALE_SYSTEM_DEFAULT, autoType, @dp, pvResult, NULL, NULL)
   
   if hr <> 0 Then
      MsgBox "函数调用失败:" + Str(hr)
   End If
   Return hr
end Function

FUNCTION VB.GetObject(BYREF wszProgID AS CONST WSTRING) AS IDispatch PTR
   DIM classID AS CLSID, pUnk AS IUnknown PTR, pDisp AS IDispatch PTR
   CLSIDFromProgID(wszProgID, @classID)
   IF IsEqualGuid(@classID, @IID_NULL) THEN RETURN NULL
   DIM hr AS HRESULT = CoInitialize(NULL)
   GetActiveObject(@classID, NULL, @pUnk)
   IF pUnk THEN
      pUnk->lpVtbl->QueryInterface(pUnk, @IID_IDispatch, @pDisp)
      pUnk->lpVtbl->Release(pUnk)
   END IF
   RETURN pDisp
End Function

FUNCTION VB.CreateObject(BYREF ProgID AS CONST WSTRING, BYREF wszIID AS CONST WSTRING = "{00020400-0000-0000-C000-000000000046}") AS ANY PTR
   DIM classID AS CLSID, riid AS IID, pUnk AS ANY PTR
   DIM hr AS HRESULT = CoInitialize(NULL)
   hr = CLSIDFromProgID(ProgID, @classID)
   if hr <> 0 Then MsgBox "创建对象失败1:" + Str(hr)
   hr = IIDFromString(wszIID, @riid)
   if hr <> 0 Then
      MsgBox "创建对象失败2:" + Str(hr)
   End If
   hr = CoCreateInstance(@classID, NULL, CLSCTX_SERVER, @riid, @pUnk)
   'obj=pUnk
   if hr <> 0 Then
      MsgBox "创建对象失败3:" + Str(hr)
   End If
   RETURN pUnk
END FUNCTION

FUNCTION VB.CreateObjectFromLib(BYREF wszLibName AS CONST WSTRING, ByVal sclsid AS LPCOLESTR, BYREF sriid AS CONST WSTRING = "{00020400-0000-0000-C000-000000000046}", BYREF wszLicKey AS WSTRING = "") AS ANY PTR
   DIM hr AS LONG, hLib AS HMODULE, pDisp AS ANY PTR
   dim rclsid AS CLSID, riid AS IID
   DIM pIClassFactory AS IClassFactory PTR, pIClassFactory2 AS IClassFactory2 PTR
   CLSIDFromString sclsid, @rclsid
   IIDFromString sriid, @riid
   hLib = GetModuleHandleW(wszLibName)
   IF hLib = NULL THEN hLib = LoadLibraryW(wszLibName)
   IF hLib = NULL THEN EXIT FUNCTION
   DIM pfnDllGetClassObject AS FUNCTION(BYVAL rclsid AS CONST IID CONST PTR, BYVAL riid AS CONST IID CONST PTR, BYVAL ppv AS LPVOID PTR) AS HRESULT
   pfnDllGetClassObject = CAST(ANY PTR, GetProcAddress(hLib, "DllGetClassObject"))
   IF pfnDllGetClassObject = NULL THEN
      msgbox "加载DLL失败"
      EXIT FUNCTION
   End If
   IF LEN(wszLicKey) = 0 THEN
      hr = pfnDllGetClassObject(@rclsid, @IID_IClassFactory, @pIClassFactory)
      IF hr <> S_OK THEN
         MsgBox "创建类厂失败" & Str(hr)
         EXIT FUNCTION
      End If
      hr = pIClassFactory->lpVtbl->CreateInstance(pIClassFactory, NULL, @riid, @pDisp)
      IF hr <> S_OK THEN
         MsgBox "创建对象失败"
         pIClassFactory->lpVtbl->Release(pIClassFactory)
         EXIT FUNCTION
      END IF
   ELSE
      hr = pfnDllGetClassObject(@rclsid, @IID_IClassFactory, @pIClassFactory2)
      IF hr <> S_OK THEN EXIT FUNCTION
      hr = pIClassFactory2->lpVtbl->CreateInstanceLic(pIClassFactory2, NULL, NULL, @riid, @wszLicKey, @pDisp)
      IF hr <> S_OK THEN
         pIClassFactory2->lpVtbl->Release(pIClassFactory2)
         EXIT FUNCTION
      END IF
   END IF
   IF pIClassFactory THEN pIClassFactory->lpVtbl->Release(pIClassFactory)
   IF pIClassFactory2 THEN pIClassFactory2->lpVtbl->Release(pIClassFactory2)
   RETURN pDisp
END FUNCTION

Extern "Windows"
function COMRegisterServer stdcall Alias "DllRegisterServer"() as HRESULT Export
   Dim p As HKEY
   RegCreateKey(HKEY_CLASSES_ROOT, "CLSID\" + CLSID_Com + "\InprocServer32", @p)
   RegSetValue(p, "", REG_SZ, App.Path & App.EXEName, Len(App.Path & App.EXEName))
   RegCloseKey p
   RegCreateKey(HKEY_CLASSES_ROOT, "CLSID\" + CLSID_Com + "\ProgID", @p)
   RegSetValue(p, "", REG_SZ, ProgID, Len(ProgID))
   RegCloseKey p
   RegCreateKey(HKEY_CLASSES_ROOT, ProgID, @p)
   RegSetValue(p, "", REG_SZ, ProgID, Len(ProgID))
   RegCloseKey p
   RegCreateKey(HKEY_CLASSES_ROOT, ProgID & "\CLSID", @p)
   RegSetValue(p, "", REG_SZ, CLSID_Com, Len(CLSID_Com))
   RegCloseKey p
   Return S_OK
End Function

function COMUnregisterServer stdcall alias "DllUnregisterServer"() as HRESULT Export
   RegDeleteKey(HKEY_CLASSES_ROOT, "CLSID\\"& CLSID_Com)
   RegDeleteKey(HKEY_CLASSES_ROOT, ProgID)
   Return S_OK
End Function

Function COMGetClassObject stdcall Alias"DllGetClassObject"(byval rclsid as const IID const ptr, byval riid as const IID const ptr, byval ppv as LPVOID ptr) as HRESULT Export
   If IsEqualIID(riid, @IID_IUnknown) Or IsEqualIID(riid, @IID_IDispatch) Or IsEqualIID(riid, @IID_IClassFactory) Then
      dim pClassFactory As IClassFactory Ptr = New IClassFactory
      if pClassFactory <> NULL Then
         pClassFactory->lpVtbl = New IClassFactoryImp
         *ppv = pClassFactory
      IUnknown_Release(pClassFactory)
      End if
   End if
   Return S_OK
End Function
'
Function COMCanUnloadNow stdcall Alias "DllCanUnloadNow"() as HRESULT Export
   
   Return S_OK
End Function

End Extern


